perm filename AEJ.F4[PIC,LCS] blob sn#092575 filedate 1974-02-12 generic text, type T, neo UTF8
	SUBROUTINE EDGE(X,Y)

C	DECEMBER 12,  68


	DIMENSION T(0/1770)

	REAL A0,A1,A2,A3,A4,A5,A6,A7,
	1 COH,B,
	2 AF,CL,C2L,CW,D,
	3 LEN,L,RO,SL,SW,
	4 S2L,RX,RY,HALF,RO2,
	5 HEL,RR,RORR,Q,LC,
	6 E,EC,ES,ECP,ESP,EX,SQ,SQP

	INTEGER COUNT,X,Y

	LOGICAL DEBUG

	COMMON /EDGEC/ A0,A1,A2,A3,A4,A5,A6,A7,
	1 DEBUG,T,
	1 HALF,FILE,RR,COH,RX,RY,CL,SL,D,B,FOUND

	CALL PROJEC(X,Y)

	Q=SQRT(6.*A1**2+2.*(A2**2+A3**2+A4**2+A5**2)+
	1 3.*(A6**2+A7**2))

	COUNT=-1
	L=1.
	CL=A2+A4
	SL=A3+A5

100	COUNT=COUNT+1
	LEN=SQRT(CL**2+SL**2)
	CL=CL/LEN
	SL=SL/LEN
	E=A2*CL+A3*SL
	IF(E.GT.0.) GOTO 200
CC	IF(E.GT.0.) GOTO 150
	CL=-CL
	SL=-SL
	E=-E
CC150	IF(.NOT.DEBUG) GOTO 200
CC	CALL ASD(2,'CL',CL)
CC	CALL ASD(2,'SL',SL)
200	C2L=CL**2-SL**2
	S2L=2.*SL*CL
	EC=A4*CL+A5*SL
	EX=A6*C2L+A7*S2L
	ES=A1+EX
	SQ=SQRT(EC**2+ES**2)
	IF(L**2.LT.1.E-3.OR.COUNT.GT.1) GOTO 250
	ECP=-A4*SL+A5*CL
	ESP=2.*(-A6*S2L+A7*C2L)
	SQP=(EC*ECP+ES*ESP)/SQ
	L=-(-A2*SL+A3*CL+SQP)/(-E+(-SQP**2+
	1 ECP**2+ESP**2-EC**2-4.*ES*EX)/SQ)
	HEL=1.-(L**2)/2.
	LC=CL
	CL=CL*HEL-SL*L
	SL=SL*HEL+LC*L
	GOTO 100

250	CW=EC/SQ
	IF(CW.GE.0.) GOTO 260
	COH=0.
	D=0.
	B=0.
	RETURN
260	SW=ES/SQ
CC	IF(.NOT.DEBUG) GOTO 300
CC	CALL ASD(4,'COUNT',COUNT)
CC	CALL ASD(4,'CW',CW)
CC	CALL ASD(4,'SW',SW)
300	AF=E+SQ
	RO=SW/(1.4142136*(1.+CW))
	RO2=RO**2
	D=AF*1.30294/((1.-RO2)**2*(1.+2.*RO2))
	COH=AF/Q
	RORR=RO*RR
	RX=FLOAT(X)+0.5-HALF+CL*RORR
	RY=FLOAT(Y)+0.5-HALF+SL*RORR
	B=A0-D*(4.+RO*(3.+RO*(2.+RO)))*((1.-RO)**2)*0.125
	IF(COH.LT.-1.0.OR.1.0.LT.COH) PAUSE 'COH CHECK IN EDGE'
CC400	IF(.NOT.DEBUG) RETURN
CC
CC	CALL ASD(3,'COH',COH)
CC	CALL ASD(3,'D',D)
CC	CALL ASD(3,'B',B)
CC	CALL ASD(3,'RX',RX)
CC	CALL ASD(3,'RY',RY)
CC	CALL ACTES(RO,D,CL,SL)
	RETURN
	END